home *** CD-ROM | disk | FTP | other *** search
/ Oh!X 2001 Spring / Oh!X 2001 Spring Special CD-ROM (Japan).7z / Oh!X 2001 Spring Special CD-ROM (Japan) (Track 1).bin / TCLTK / NAPON / napon.tcl < prev   
Text File  |  2000-05-07  |  13KB  |  523 lines
  1. #
  2. # NAPON.TCL : ならべてポン！
  3. #
  4. #             Copyright (C) 1999 by Makoto Hiroi
  5. #
  6. # 盤面は 4 * 4 (1 - 3),
  7. #        5 * 5 (1 - 4),
  8. #        6 * 6 (1 - 5), 
  9. # 外部変数
  10. #   board()     : 盤面（データを格納）
  11. #                 上位 4 ビットで色、下位 4 ビットで数字を表す
  12. #   number()    : テキスト ID を格納
  13. #   numstr()    : 表示する文字列
  14. #   color()     : 表示する色
  15. #   piece()     : 図形 ID を格納
  16. #   font_type() : フォント
  17. #   size        : 盤面の大きさ
  18. #   play_flag   : ゲームの状態
  19. #                 0 : not play
  20. #                 1 : play 
  21. #                 2 : use takeback
  22. #   buff1       : メッセージ表示用バッファ
  23. #   buff2       : 名前入力用バッファ
  24. #   time        : ゲーム開始時刻
  25. #   id          : after コマンドが返す固有番号
  26. #   history()   : 取った牌の履歴
  27. #   move_cnt    : 手数
  28. #   name()      : トップテン(1 - 10, 0 is dummy)
  29. #   date()
  30. #   score()
  31. #
  32.  
  33. # 色
  34. set color(0) red
  35. set color(1) blue
  36. set color(2) green
  37. set color(3) gold
  38. set color(4) purple
  39. set color(5) pink
  40.  
  41. # 数字
  42. set numstr(0) "  "
  43. set numstr(1) "１"
  44. set numstr(2) "２"
  45. set numstr(3) "３"
  46. set numstr(4) "４"
  47. set numstr(5) "５"
  48.  
  49. # フォント
  50. set font_type(4) "{ＭＳ ゴシック} 48"
  51. set font_type(5) "{ＭＳ ゴシック} 36"
  52. set font_type(6) "{ＭＳ ゴシック} 28"
  53.  
  54. # ヘルプファイルの表示
  55. proc help {} {
  56.     global path_name
  57.     if {![winfo exist .t0]} {
  58.         toplevel .t0
  59.         wm title .t0 "NarabetePon Help"
  60.         text .t0.text -yscrollcommand ".t0.scroll set"
  61.         scrollbar .t0.scroll -command ".t0.text yview"
  62.     pack .t0.scroll -side right -fill y
  63.     pack .t0.text -side left
  64.     # ファイルの読み込み
  65.     set f [open "$path_name/NAP_HELP.TXT" r]
  66.     while {![eof $f]} {
  67.         .t0.text insert end [read $f 1000]
  68.     }
  69.     close $f
  70.     }
  71. }
  72.  
  73. # スコアファイルリード
  74. proc read_score_file {} {
  75.     global score_file name date score
  76.     set now_date [clock seconds]
  77.     if [file exists $score_file] {
  78.     # ファイルの読み込み
  79.     set f [open $score_file r]
  80.     foreach j {4 5 6} {
  81.         for {set i 1} {$i <= 10} {incr i} {
  82.         if {[gets $f line] < 0} {
  83.             # ダミーデータをセット
  84.             set l " \t$now_data\t5999"
  85.         }
  86.         set l [split $line "\t"]
  87.         set name($j,$i)  [lindex $l 0]
  88.         set date($j,$i)  [lindex $l 1]
  89.         set score($j,$i) [lindex $l 2]
  90.         }
  91.     }
  92.     close $f
  93.     } else {
  94.     # ダミーデータのセット
  95.     foreach j {4 5 6} {
  96.         for {set i 1} {$i <= 10} {incr i} {
  97.         set name($j,$i) ""
  98.         set date($j,$i) $now_date
  99.         # 5999 は 99:59 です
  100.         set score($j,$i) 5999
  101.         }
  102.     }
  103.     }
  104. }
  105.  
  106. # スコアファイルライト
  107. proc write_score_file {} {
  108.     global score_file name date score
  109.     set f [open $score_file w]
  110.     foreach j {4 5 6} {
  111.     for {set i 1} {$i <= 10} {incr i} {
  112.         puts $f [format "%s\t%d\t%d" $name($j,$i) $date($j,$i) $score($j,$i)]
  113.     }
  114.     }
  115.     close $f
  116. }
  117.  
  118.  
  119. # ********** スコア表示 ********
  120.  
  121. # 秒数をスコアに変換
  122. proc change_seconds {s} {
  123.     return [format "%02d:%02d" [expr $s / 60] [expr $s % 60]]
  124. }
  125.  
  126. #
  127. # トップテンウィンドウを開く
  128. #
  129. proc open_score_window {ranking} {
  130.     global name date score size
  131.     if [winfo exists .t1] {
  132.     destroy .t1
  133.     }
  134.     toplevel .t1
  135.     wm title .t1 "Top 10"
  136.     frame .t1.f0
  137.     frame .t1.f1
  138.     label .t1.f0.l0 -text "順位  名前" -anchor w
  139.     label .t1.f1.l0 -text "記録    日付  " -anchor w
  140.     pack .t1.f0.l0 -fill x
  141.     pack .t1.f1.l0 -fill x
  142.     for {set i 1} {$i <= 10} {incr i} {
  143.     label .t1.f0.l$i -text [format "%4d %-20s" $i $name($size,$i)] -anchor w
  144.     label .t1.f1.l$i -text [format "%5s %8s" \
  145.                 [change_seconds $score($size,$i)] \
  146.                 [clock format $date($size,$i) -format "%y/%m/%d"]]
  147.     pack  .t1.f0.l$i -fill x
  148.     pack  .t1.f1.l$i -fill x
  149.     }
  150.     if {$ranking > 0} {
  151.     .t1.f0.l$ranking configure -fg red
  152.     .t1.f1.l$ranking configure -fg red
  153.     }
  154.     pack .t1.f0 .t1.f1 -side left
  155. }
  156.  
  157. # ベストテンに入るか
  158. proc check_hi_score {now_score} {
  159.     global score size
  160.     for {set i 1} {$i <= 10} {incr i} {
  161.     if {$score($size,$i) > $now_score} {
  162.         # ベストテンに入ったよ
  163.         return $i
  164.     }
  165.     }
  166.     return 0
  167. }
  168.  
  169. # スコアの更新
  170. proc update_score {n d s o} {
  171.     global name date score size
  172.     for {set i 9} {$i >= $o} {incr i -1} {
  173.     set j [expr $i + 1]
  174.     set name($size,$j) $name($size,$i)
  175.     set date($size,$j) $date($size,$i)
  176.     set score($size,$j) $score($size,$i)
  177.     }
  178.     set name($size,$o) $n
  179.     set date($size,$o) $d
  180.     set score($size,$o) $s
  181. }
  182.  
  183. # トップテンの名前入力
  184. proc input_hi_score_name {ranking} {
  185.     global buff2
  186.     set buff2 ""
  187.     toplevel .t2
  188.     wm title .t2 "Input Your Name"
  189.     wm geometry .t2 "+[expr [winfo x .] + 120]+[expr [winfo y .] + 180]"
  190.     label .t2.l0 -text [format "おめでとう！ %d 位です" $ranking]
  191.     label .t2.l1 -text "名前を入力してね"
  192.     entry .t2.e0 -textvariable buff2
  193.     focus -force .t2.e0
  194.     grab set -global .t2
  195.     bind .t2.e0 <Return> {
  196.     # 入力チェックが必要か
  197.     if {$buff2 != ""} {
  198.         destroy .t2
  199.     }
  200.     }
  201.     pack .t2.l0 .t2.l1 .t2.e0
  202. }
  203.  
  204. # 盤面から色を求める
  205. proc get_color {x y} {
  206.     global board
  207.     return [expr $board($x,$y) / 16]
  208. }
  209.  
  210. # 盤面から数字を求める
  211. proc get_number {x y} {
  212.     global board
  213.     return [expr $board($x,$y) % 16]
  214. }
  215.  
  216. # 完成したか
  217. proc check_finish {} {
  218.     global size
  219.     for {set y 0} {$y < $size} {incr y} {
  220.     set c [get_color 0 $y]
  221.     set i [expr $size - 1]
  222.     for {set x 0} {$x < $i} {incr x} {
  223.         if {[get_number $x $y] != [expr $x + 1] || [get_color $x $y] != $c} {
  224.         return 0
  225.         }
  226.     }
  227.     }
  228.     return 1
  229. }
  230.  
  231. # 手詰まりの判定
  232. proc check_game_over {} {
  233.     global size
  234.     for {set y 0} {$y < $size} {incr y} {
  235.     if {[get_number 0 $y] == 0} {
  236.         return 0
  237.     }
  238.     }
  239.     for {set x 1} {$x < $size} {incr x} {
  240.     for {set y 0} {$y < $size} {incr y} {
  241.         if {[get_number $x $y] == 0} {
  242.         set n [get_number [expr $x - 1] $y]
  243.         if {$n != 0 && $n != [expr $size - 1]} {
  244.             return 0
  245.         }
  246.         }
  247.     }
  248.     }
  249.     return 1
  250. }
  251.  
  252.  
  253. # カードを探して右隣へ移動できるか
  254. proc search_and_move {card} {
  255.     global board size
  256.     set i [expr $size - 1]
  257.     for {set x 0} {$x < $i} {incr x} {
  258.     for {set y 0} {$y < $size} {incr y} {
  259.         if {$board($x,$y) == $card} {
  260.         if {[get_number [expr $x + 1] $y] == 0} {
  261.             # 右隣は空いている
  262.             return [concat [expr $x + 1] $y]
  263.         }
  264.         }
  265.     }
  266.     }
  267.     return ""
  268. }
  269.  
  270. # カードを移動できるか
  271. proc check_move_card {x y} {
  272.     global board size
  273.     set c [get_color $x $y]
  274.     set n [get_number $x $y]
  275.     if {$n == 1} {
  276.     set y1 [expr {($x == 0) ? $y : 0}]
  277.     for {set i 0} {$i < $size} {incr i} {
  278.         if {[get_number 0 $y1] == 0} {
  279.         return [concat 0 $y1]
  280.         }
  281.         incr y1
  282.         if {$y1 == $size} {
  283.         set y1 0
  284.         }
  285.     }
  286.     } else {
  287.     return [search_and_move [expr 16 * $c + $n - 1]]
  288.     }
  289.     return ""
  290. }
  291.  
  292. # カードの表示
  293. proc draw_piece {x y} {
  294.     global piece number numstr color font_type size
  295.     set c [get_color $x $y]
  296.     set n [get_number $x $y]
  297.     .c0 itemconfigure $number($x,$y) -text $numstr($n) \
  298.         -fill $color($c) \
  299.         -font $font_type($size)
  300.     if {$n == 0} {
  301.     # 裏面
  302.     .c0 itemconfigure $piece($x,$y) -fill darkgreen
  303.     } else {
  304.     .c0 itemconfigure $piece($x,$y) -fill white
  305.     }
  306. }
  307.  
  308. # カードの移動
  309. proc move_card {x0 y0 x1 y1} {
  310.     global board
  311.     set temp $board($x0,$y0)
  312.     set board($x0,$y0) $board($x1,$y1)
  313.     set board($x1,$y1) $temp
  314.     draw_piece $x0 $y0
  315.     draw_piece $x1 $y1
  316. }
  317.  
  318. # カードを押した時の処理
  319. proc push_piece {x y} {
  320.     global id time play_flag buff2 move_cnt history
  321.     set pos [check_move_card $x $y]
  322.     if {$pos != ""} {
  323.     # カードの移動
  324.     eval move_card $x $y $pos
  325.     set history($move_cnt) [concat $x $y $pos]
  326.     incr move_cnt
  327.     }
  328.     if [check_finish] {
  329.     # 終了
  330.     set t [clock seconds]
  331.     set s [expr $t - $time]
  332.     after cancel $id
  333.     set ranking [check_hi_score $s]
  334.     if {$ranking > 0 && $play_flag == 1} {
  335.         input_hi_score_name $ranking 
  336.         tkwait window .t2
  337.         update_score $buff2 $t $s $ranking
  338.         write_score_file
  339.         open_score_window $ranking
  340.     } else {
  341.         tk_messageBox -type ok \
  342.         -message [format "おめでとう %s です" [change_seconds $s]]
  343.     }
  344.     set play_flag 0
  345.     } elseif [check_game_over] {
  346.     after cancel $id
  347.     set play_flag 0
  348.     tk_messageBox -type ok -message "手詰まりです"
  349.     }
  350. }
  351.  
  352. # 図形の初期化
  353. proc init_item {} {
  354.     global piece number
  355.     # 背景
  356.     .c0 create rectangle 0 0 239 239 -fill darkgreen
  357.     # 図形の設定
  358.     for {set x 0} {$x < 6} {incr x} {
  359.     for {set y 0} {$y < 6} {incr y} {
  360.         set piece($x,$y) [.c0 create rectangle 0 0 10 10 -fill white]
  361.         set number($x,$y) [.c0 create text $x $y -text " "]
  362.         .c0 bind $piece($x,$y)  <Button-1> "push_piece $x $y"
  363.         .c0 bind $number($x,$y) <Button-1> "push_piece $x $y"
  364.         .c0 lower $piece($x,$y)
  365.         .c0 lower $number($x,$y)
  366.     }
  367.     }
  368. }
  369.  
  370. # 盤面の設定
  371. proc make_board {} {
  372.     global board size
  373.     # piece_table は局所変数
  374.     for {set i 0; set c 0} {$c < $size} {incr c} {
  375.     for {set n 0} {$n < $size} {incr n} {
  376.         # piece_tabale の初期化
  377.         set piece_table($i) [expr $c * 16 + $n]
  378.         incr i
  379.     }
  380.     }
  381.     # 乱数でかき回す
  382.     for {set j 0} {$j < $i} {incr j} {
  383.     set n    [expr int( rand() * $i )]
  384.     set temp $piece_table($n)
  385.     set piece_table($n) $piece_table($j)
  386.     set piece_table($j) $temp
  387.     }
  388.     # board にセット
  389.     set i 0
  390.     for {set y 0} {$y < $size} {incr y} {
  391.     for {set x 0} {$x < $size} {incr x} {
  392.         set board($x,$y) $piece_table($i)
  393.         incr i
  394.     }
  395.     }
  396. }
  397.  
  398. # 図形のサイズ変更
  399. proc change_item {} {
  400.     global piece number size
  401.     set w [expr 240 / $size]
  402.     for {set x 0} {$x < 6} {incr x} {
  403.     for {set y 0} {$y < 6} {incr y} {
  404.         if {$x < $size && $y < $size} {
  405.         set x1 [expr $x * $w]
  406.         set y1 [expr $y * $w]
  407.         set x2 [expr $x1 + $w - 1]
  408.         set y2 [expr $y1 + $w - 1]
  409.         .c0 coords $piece($x,$y) $x1 $y1 $x2 $y2
  410.         .c0 coords $number($x,$y) [expr $x1 + $w / 2] [expr $y1 + $w / 2]
  411.         } else {
  412.         .c0 lower $piece($x,$y)
  413.         .c0 lower $number($x,$y)
  414.         }
  415.     }
  416.     }
  417. }
  418.  
  419.  
  420. # 盤面の表示
  421. proc draw_board {} {
  422.     global piece number size
  423.     for {set x 0} {$x < $size} {incr x} {
  424.     for {set y 0} {$y < $size} {incr y} {
  425.         draw_piece $x $y
  426.         .c0 raise $piece($x,$y)
  427.         .c0 raise $number($x,$y)
  428.     }
  429.     }
  430. }
  431.  
  432. # メッセージの表示
  433. proc display_message {} {
  434.     global time buff1
  435.     set t [expr [clock seconds] - $time]
  436.     set buff1 [format "時間 %5s" [change_seconds $t]]
  437. }
  438.  
  439. # 時間の表示
  440. proc display_time {} {
  441.     global id
  442.     display_message
  443.     set id [after 1000 display_time]
  444. }
  445.  
  446. # 一手もどす
  447. proc takeback {} {
  448.     global history move_cnt play_flag
  449.     if {$move_cnt > 0 && $play_flag > 0} {
  450.     incr move_cnt -1
  451.     set x1 [lindex $history($move_cnt) 0]
  452.     set y1 [lindex $history($move_cnt) 1]
  453.     set x2 [lindex $history($move_cnt) 2]
  454.     set y2 [lindex $history($move_cnt) 3]
  455.     move_card $x1 $y1 $x2 $y2
  456.     }
  457. }
  458.  
  459. # ゲームの開始
  460. proc start_game {} {
  461.     global play_flag time id move_cnt
  462.     if {$play_flag > 0} {
  463.     after cancel $id
  464.     }
  465.     while 1 {
  466.     make_board
  467.     change_item
  468.     if ![check_game_over] break
  469.     }
  470.     draw_board
  471.     set play_flag 1
  472.     set move_cnt 0
  473.     set time [clock seconds]
  474.     display_time
  475. }
  476.  
  477.  
  478.  
  479. # ********** メニューの設定 **********
  480. menu .m -type menubar
  481. . configure -menu .m
  482. .m add cascade -label "Games"    -under 0 -menu .m.m1
  483. .m add command -label "Takeback" -under 0 -command "takeback"
  484. .m add cascade -label "Size"     -under 0 -menu .m.m2
  485. .m add command -label "Help"     -under 0 -command "help"
  486. menu .m.m1 -tearoff no
  487. .m.m1 add command -label "Start"   -under 0 -command "start_game"
  488. .m.m1 add command -label "HiScore" -under 0 -command "open_score_window 0"
  489. .m.m1 add separator
  490. .m.m1 add command -label "Exit" -under 0 -command "exit"
  491. menu .m.m2 -tearoff no
  492. .m.m2 add radiobutton -label "4 * 4" -variable size -value 4 -command "start_game"
  493. .m.m2 add radiobutton -label "5 * 5" -variable size -value 5 -command "start_game"
  494. .m.m2 add radiobutton -label "6 * 6" -variable size -value 6 -command "start_game"
  495.  
  496. # オプションの設定
  497. option add *font "{ＭＳ ゴシック} 12"
  498.  
  499. # 画面の設定 (240 * 240) 60, 48, 40
  500. canvas .c0 -width 240 -height 240
  501.  
  502. # 表示用ラベル
  503. label .l1 -textvariable buff1 -bg darkgreen -fg white -anchor e
  504.  
  505. pack .l1 .c0 -fill x
  506.  
  507. # 窓の題名
  508. wm title . "NarabetePon"
  509. wm resizable . 0 0
  510.  
  511. # 初期化
  512. set play_flag 0
  513. set size      4
  514. set path_name [file dirname $argv0]
  515. set score_file "$path_name/NAPON.SCO"
  516. init_item
  517.  
  518. # スコアファイルのリード
  519. read_score_file
  520. focus -force .
  521.  
  522. # end of file
  523.